home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / unixFont.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  9.6 KB  |  294 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the procedures in tkUnixFont.c. 
  2. # It is organized in the standard fashion for Tcl tests.
  3. #
  4. # Many of these tests are visually oriented and cannot be checked
  5. # programmatically (such as "does an underlined font appear to be
  6. # underlined?"); these tests attempt to exercise the code in question,
  7. # but there are no results that can be checked.  Some tests depend on the
  8. # fonts having or not having certain properties, which may not be valid
  9. # at all sites.  
  10. #
  11. # Copyright (c) 1996 Sun Microsystems, Inc.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16. # SCCS: @(#) unixFont.test 1.7 97/06/24 13:34:24
  17.  
  18. if {$tcl_platform(platform)!="unix"} {
  19.     return
  20. }
  21.  
  22. if {[string compare test [info procs test]] != 0} {
  23.     source defs
  24. }
  25.  
  26. catch {destroy .b}
  27. toplevel .b
  28. wm geom .b +0+0
  29. update idletasks
  30.  
  31. # Font should be fixed width and have chars missing below char 32, so can
  32. # test control char expansion and missing character code.
  33.  
  34. set courier {Courier -10}
  35. set cx [font measure $courier 0]
  36.  
  37. label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font fixed
  38. pack .b.l
  39. canvas .b.c -closeenough 0
  40.  
  41. set t [.b.c create text 0 0 -anchor nw -just left -font $courier]
  42. pack .b.c
  43. update
  44.  
  45. set ax [winfo reqwidth .b.l]
  46. set ay [winfo reqheight .b.l]
  47. proc getsize {} {
  48.     update
  49.     return "[winfo reqwidth .b.l] [winfo reqheight .b.l]"
  50. }
  51.  
  52. test unixfont-1.1 {TkpGetNativeFont procedure: not native} {
  53.     list [catch {font measure {} xyz} msg] $msg
  54. } {1 {font "" doesn't exist}}
  55. test unixfont-1.2 {TkpGetNativeFont procedure: native} {
  56.     font measure fixed 0
  57. } {6}
  58.  
  59. test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} {
  60.     font actual {-size 10}
  61.     set x {}
  62. } {}
  63. test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} {
  64.     set x {}
  65.     lappend x [lindex [font actual {-family "Times New Roman"}] 1]
  66.     lappend x [lindex [font actual {-family "New York"}] 1]
  67.     lappend x [lindex [font actual {-family "Times"}] 1]
  68. } {times times times}
  69. test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} {
  70.     set x {}
  71.     lappend x [lindex [font actual {-family "Courier New"}] 1]
  72.     lappend x [lindex [font actual {-family "Monaco"}] 1]
  73.     lappend x [lindex [font actual {-family "Courier"}] 1]
  74. } {courier courier courier}
  75. test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} {
  76.     set x {}
  77.     lappend x [lindex [font actual {-family "Arial"}] 1]
  78.     lappend x [lindex [font actual {-family "Geneva"}] 1]
  79.     lappend x [lindex [font actual {-family "Helvetica"}] 1]
  80. } {helvetica helvetica helvetica}
  81. test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} {
  82.     font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*}
  83.     set x {}
  84. } {}
  85. test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} {
  86.     lindex [font actual {-family fixed -size 10}] 1
  87. } {fixed}
  88. test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} {
  89.     # no test available
  90. } {}
  91. test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} {
  92.     lindex [font actual {-family fixed -size 31}] 1
  93. } {fixed}
  94. test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {
  95.     lindex [font actual {-family courier}] 1
  96. } {courier}
  97. test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} {
  98.     lindex [font actual {-family courier -size 37}] 3
  99. } {37}
  100. test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} {
  101.     # On Linux, XListFonts() was returning names for fonts that do not
  102.     # actually exist, causing the subsequent XLoadQueryFont() to fail
  103.     # unexpectedly.  Now falls back to another font if that happens.
  104.  
  105.     font actual {-size 14}
  106.     set x {}
  107. } {}    
  108.  
  109. test unixfont-3.1 {TkpDeleteFont procedure} {
  110.     font actual {-family xyz}
  111.     set x {}
  112. } {}
  113.  
  114. test unixfont-4.1 {TkpGetFontFamilies procedure} {
  115.     font families
  116.     set x {}
  117. } {}
  118.  
  119. test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} {
  120.     .b.l config -text "000000" -wrap [expr $ax*3]
  121.     .b.l config -wrap 0
  122. } {}
  123. test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} {
  124.     .b.l config -text "000000"
  125. } {}
  126. test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} {
  127.     .b.l config -text "0"
  128.     .b.l config -text "\377"
  129.     .b.l config -text "0\3770\377"
  130.     .b.l config -text "000000000000000"
  131. } {}
  132. .b.l config -wrap [expr $ax*10]
  133. test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} {
  134.     .b.l config -text "0000000000000"
  135.     getsize
  136. } "[expr $ax*10] [expr $ay*2]"
  137. test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} {
  138.     .b.l config -text "000000"
  139.     getsize
  140. } "[expr $ax*6] $ay"
  141. test unixfont-5.6 {Tk_MeasureChars procedure: find last word} {
  142.     .b.l config -text "000000 00000"
  143.     getsize
  144. } "[expr $ax*6] [expr $ay*2]"
  145. test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} {
  146.     .b.l config -text "000000     00000"
  147.     getsize
  148. } "[expr $ax*6] [expr $ay*2]"
  149. test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} {
  150.     .b.l config -text "00  000     00000"
  151.     getsize
  152. } "[expr $ax*7] [expr $ay*2]"
  153. test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} {
  154.     .b.c dchars $t 0 end
  155.     .b.c insert $t 0 "0000"
  156.     .b.c index $t @[expr int($ax*2.5)],1
  157. } {2}
  158. test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} {
  159.     .b.l config -text "000000000000"
  160.     getsize
  161. } "[expr $ax*10] [expr $ay*2]"
  162. test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} {
  163.     set a [.b.l cget -wrap]
  164.     .b.l config -text "000000" -wrap 1
  165.     set x [getsize]
  166.     .b.l config -wrap $a
  167.     set x
  168. } "$ax [expr $ay*6]"
  169. test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} {
  170.     .b.l config -text "000   \n000"
  171.     getsize
  172. } "[expr $ax*6] [expr $ay*2]"
  173.  
  174. test unixfont-6.1 {Tk_DrawChars procedure: loop test} {
  175.     .b.l config -text "a"
  176.     update
  177. } {}
  178. test unixfont-6.2 {Tk_DrawChars procedure: loop test} {
  179.     .b.l config -text "abcd"
  180.     update
  181. } {}
  182. test unixfont-6.3 {Tk_DrawChars procedure: special char} {
  183.     .b.l config -text "\001"
  184.     update
  185. } {}
  186. test unixfont-6.4 {Tk_DrawChars procedure: normal then special} {
  187.     .b.l config -text "ab\001"
  188.     update
  189. } {}
  190. test unixfont-6.5 {Tk_DrawChars procedure: ends with special} {
  191.     .b.l config -text "ab\001"
  192.     update
  193. } {}
  194. test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} {
  195.     .b.l config -text "ab\001def"
  196.     update
  197. } {}
  198.  
  199. test unixfont-7.1 {DrawChars procedure: no effects} {
  200.     .b.l config -text "abc"
  201.     update
  202. } {}
  203. test unixfont-7.2 {DrawChars procedure: underlining} {
  204.     set f [.b.l cget -font]
  205.     .b.l config -text "abc" -font "courier 10 underline"
  206.     update
  207.     .b.l config -font $f
  208. } {}
  209. test unixfont-7.3 {DrawChars procedure: overstrike} {
  210.     set f [.b.l cget -font]
  211.     .b.l config -text "abc" -font "courier 10 overstrike"
  212.     update
  213.     .b.l config -font $f
  214. } {}
  215.  
  216. test unixfont-8.1 {AllocFont procedure: use old font} {
  217.     font create xyz
  218.     button .c -font xyz
  219.     font configure xyz -family times
  220.     update
  221.     destroy .c
  222.     font delete xyz
  223. } {}
  224. test unixfont-8.2 {AllocFont procedure: parse information from XLFD} {
  225.     expr [lindex [font actual {-family times -size 0}] 3]==0
  226. } {0}
  227. test unixfont-8.3 {AllocFont procedure: can't parse info from name} {
  228.     if [catch {set a [font actual a12biluc]}]==0 {
  229.     string compare $a "-family a12biluc -size 0 -weight normal -slant roman -underline 0 -overstrike 0"
  230.     } else {
  231.     set a 0
  232.     }
  233. } {0}
  234. test unixfont-8.4 {AllocFont procedure: classify characters} {
  235.     set x 0
  236.     incr x [font measure $courier "\001"]   ;# 4
  237.     incr x [font measure $courier "\002"]   ;# 4
  238.     incr x [font measure $courier "\012"]   ;# 2
  239.     incr x [font measure $courier "\101"]   ;# 1
  240.     set x
  241. } [expr $cx*11]
  242. test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} {
  243.     font metrics $courier -fixed
  244. } {1}
  245. test unixfont-8.6 {AllocFont procedure: setup widths of special chars} {
  246.     set x 0
  247.     incr x [font measure $courier "\001"]   ;# 4
  248.     incr x [font measure $courier "\002"]   ;# 4
  249.     incr x [font measure $courier "\012"]   ;# 2
  250.     set x
  251. } [expr $cx*10]
  252. test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} {
  253.     catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
  254.     set x {}
  255. } {}
  256. test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} {
  257.     catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
  258.     set x {}
  259. } {}
  260. test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} {
  261.     catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
  262.     set x {}
  263. } {}
  264. test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} {
  265.     catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific}
  266.     set x {}
  267. } {}
  268. test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} {
  269.     catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1}
  270.     set x {}
  271. } {}
  272.  
  273. test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} {
  274.     .b.c dchars $t 0 end
  275.     .b.c insert $t 0 "0\a0"
  276.     set x {}
  277.     lappend x [.b.c index $t @[expr $ax*0],0]
  278.     lappend x [.b.c index $t @[expr $ax*1],0]
  279.     lappend x [.b.c index $t @[expr $ax*2],0]
  280.     lappend x [.b.c index $t @[expr $ax*3],0]
  281. } {0 1 1 2}
  282. test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} {
  283.     .b.c dchars $t 0 end
  284.     .b.c insert $t 0 "0\1770"
  285.     set x {}
  286.     lappend x [.b.c index $t @[expr $ax*0],0]
  287.     lappend x [.b.c index $t @[expr $ax*1],0]
  288.     lappend x [.b.c index $t @[expr $ax*2],0]
  289.     lappend x [.b.c index $t @[expr $ax*3],0]
  290.     lappend x [.b.c index $t @[expr $ax*4],0]
  291.     lappend x [.b.c index $t @[expr $ax*5],0]
  292. } {0 1 1 1 1 2}
  293.  
  294.